procedure AdvanceRoi;
begin
  hloc:=hloc+RoiWidth;
  if (hloc+RoiWidth div 2)>PicWidth then begin
    hloc:=0;
    vloc:=vloc+RoiHeight;
  end;
  if (hloc+RoiWidth)>PicWidth then hloc:=PicWidth-RoiWidth;
  if (vloc+RoiHeight)>PicHeight then vloc:=PicHeight-RoiHeight;
  MakeRoi(hloc,vloc,RoiWidth,RoiHeight);
end;


procedure MakeBlocks(n:integer);
var
  i,hloc,vloc,PicWidth,PicHeight:integer;
  RoiWidth,RoiHeight:integer;
  scale:real;
begin
  GetPicSize(PicWidth,PicHeight);
  scale:=1/n;
  SelectAll;
  SetScaling('Nearest Neighbor; Same Window');
  ScaleAndRotate(scale,scale,0);
  RestoreRoi;
  GetRoi(hloc,vloc,RoiWidth,RoiHeight);
  copy;
  SelectAll;
  Clear;
  hloc:=0;
  vloc:=0;
  MakeRoi(hloc,vloc,RoiWidth,RoiHeight);
  for i:=1 to n*n do begin
    Paste;
    AdvanceRoi;
  end;
  KillRoi;
end;


procedure DoTextDemo;
begin
  RevertToSaved;
  MoveTo(100,20);
  SetForegroundColor(255);
  SetBackgroundColor(0);
  SetFont('Geneva');
  SetFontSize(24);
  SetText('No background, Bold, Center');
  Writeln('Text');
  SetText('With background');
  Writeln('With Background');
  SetText('Bold');
  Writeln('Bold');
  SetText('Underlined');
  Writeln('Underlined');
  SetText('Italic');
  Writeln('Italics');
  SetText('Outline');
  Writeln('Outlined');
  SetText('Shadow');
  Writeln('Shadowed');
  SetText('Plain');
  SetFontSize(9);
  MoveTo(100,240);
  Writeln('Very small');
  wait(.5);
  SetFontSize(24);
  MoveTo(100,240);
  Writeln('Small');
  wait(.5);
  SetFontSize(48);
  MoveTo(100,240);
  SetText('Bold');
  Writeln('MEDIAN');
  wait(.5);
  SetFontSize(96);
  MoveTo(100,240);
  Writeln('LARGE');
  wait(1);
end;


procedure DrawGrayLevelScale(nBoxes:integer);
var
  PicWidth, PicHeight,i,GrayLevel,hloc,vloc,width,height,vdelta:integer;
begin
  GetPicSize(PicWidth,PicHeight);
  SetFont('Helvetica');
  SetFontSize(9);
  SetText('Bold; Center; with background');
  SetBackgroundColor(0);
  width:=0.9*PicHeight/nBoxes;
  height:=width;
  hloc:=0.05*PicHeight;
  vloc:=hloc;
  vdelta:=height-1;
  GrayLevel:=0;
  for i:=1 to nBoxes do begin
    MakeRoi(hloc,vloc,width,height);
    SetForeground(GrayLevel);
    Fill;
    SetForeground(255);
    DrawBoundary;
    MoveTo(hloc+width/2,vloc+height/2);
    Writeln(GrayLevel);
    GrayLevel:=GrayLevel+trunc(256/nBoxes);
    vloc:=vloc+vdelta;
  end;
end;


procedure DrawColorScale;
var
  top,left,width,height,nLabels,i,tvloc:integer;
begin
  nLabels:=16;
  SetFontSize(12);
  SetFont('Helvetica');
  SetText('Right Justified');
  DrawScale;
  GetRoi(left,top,width,height);
  KillRoi;
  SetForeground(255); {black}
  SetBackground(0); {255}
  vloc:=top;
  for i:=1 to nLabels do begin
    MoveTo(left+width+25,vloc+3);
    tvloc:=vloc;
    if tvloc>(top+height-1) then tvloc:=Top+height-1;
    Writeln(GetPixel(left,tvloc));
    vloc:=vloc+round(height/(nLabels-1));
  end; 
end;


procedure DoColorScaleDemo;
var
  PicWidth,PicHeight,hloc,vloc,ScaleWidth,ScaleHeight:integer;
begin
  GetPicSize(PicWidth,PicHeight);
  width:=0.1*PicWidth;
  if width>40 then width:=40;
  height:=0.9*PicHeight;
  hloc:=0.05*PicHeight;
  vloc:=hloc;
  SetPalette('Spectrum');
  MakeRoi(hloc,vloc,width,height);
  DrawColorScale;
  wait(2);
  SetPalette('Grayscale');
end;


procedure DemoFilters;
var
  hloc,vloc,RoiWidth,RoiHeight,PicWidth,PicHeight:integer;
begin
  MakeBlocks(3);
  RestoreRoi;
  GetRoi(hloc,vloc,RoiWidth,RoiHeight);
  GetPicSize(PicWidth,PicHeight);
  hloc:=0; vloc:=0;
  AdvanceRoi;
  SetOption; Sharpen;
  AdvanceRoi;
  Shadow;
  AdvanceRoi;
  TraceEdges;
  AdvanceRoi;
  SetOption; Smooth;
  TraceEdges;
  Skeletonize;
  AdvanceRoi;
  Dither;
  AdvanceRoi;
  Invert;
  AdvanceRoi;
  FlipVertical;
  AdvanceRoi;
  FlipHorizontal;
end;


procedure MakeGrayLevelGrid;
var
  i,hloc,vloc,PicWidth,PicHeight:integer;
  RoiWidth,RoiHeight,GrayLevel,increment:integer;
  scale:real;
begin
  n:=5;
  GetPicSize(PicWidth,PicHeight);
  hloc:=0;
  vloc:=0;
  RoiWidth:=PicWidth div n;
  RoiHeight:=PicHeight div n;
  MakeRoi(hloc,vloc,RoiWidth,RoiHeight);
  GrayLevel:=255;
  increment:=round(256/(n*n));
  SetLineWidth(1);
  for i:=1 to n*n do begin
    SetForeground(GrayLevel);
    fill;
    SetForeground(0);
    DrawBoundary;
    GrayLevel:=GrayLevel-increment;
    if GrayLevel<0 then GrayLevel:=0;
    AdvanceRoi;
  end;
  KillRoi;
end;


macro 'Demo Macro [D]'
{
This macro demonstrate many of the features available in Image's macro
language. It assumes the Image at least as large as`256x256 has been opened.
}
var
  i:integer;
  width,height,n,W,H:integer;
  scale:real;
  NoImage:boolean;
  StartTicks,time:real;
begin
  StartTicks:=TickCount;
  NoImage:=nPics<>1;
  if not NoImage then GetPicSize(width,height);
  if NoImage or (width<256) or (height<256) then begin
    PutMessage('This macro needs a single image at least 256 pixels wide and 256 pixels high  to operate on.');
    Exit;
  end;
 
  SaveState;
  DemoFilters;
  wait(2);

  RevertToSaved;
  MakeGrayLevelGrid;
  wait(1);

  RevertToSaved;
  DrawGrayLevelScale(12);
  wait(1);

  RevertToSaved;
  DoColorScaleDemo;

  DoTextDemo;


  RevertToSaved;
  SetScaling('Nearest Neighbor; Same Window');
  for i:= 1 to 4 do begin
    ScaleAndRotate(1.5,1.5,0);
    wait(.5);
  end;

  RevertToSaved;
  for i:=1 to 6 do begin
    ScaleAndRotate(0.6,0.6,0);
    wait(.5);
    RestoreRoi;
  end;

  RevertToSaved;
  wait(.5);
  ScaleAndRotate(.333,1,0);
  wait(1);
  Undo;
  ScaleAndRotate(1,.333,0);
  wait(1);

  Undo;
  FlipVertical;
  wait(.5);
  Undo;
  FlipHorizontal;
  wait(.5);
  Undo;
  RotateRight(true);
  RotateLeft(true);

  Shadow;
  Wait(1);

  Undo;
  Duplicate('Temp');
  Smooth;
  for i:=1 to 3 do begin SetOption; Sharpen end;
  wait(.5);
  Dispose;
  SelectPic(1);
  Dither;
  wait(.5);

  Undo;
  AddConstant(100);
  Wait(1);
  Undo;
  AddConstant(-100);
  Wait(1);
  EnhanceContrast;
  Wait(.5);
  Undo;
  EqualizeHistogram;
  Wait(.5);
  ResetGraymap;
  ShowHistogram;

  Smooth;
  TraceEdges;
  wait(.5);
  Erode;
  Dilate;
  Outline;
  Undo;
  Skeletonize;
  Wait(1);
  for i:= 1 to 12 do TraceEdges;
  RestoreState;
  time:=(TickCount-StartTicks)/60;
  ShowMessage('time=',time:1:2,' seconds');
end;


macro 'Make Wallpaper [M]'
var
  width,height,n:integer;
begin
  GetPicSize(width,height);
  if (width=0) then begin
    PutMessage('This macro needs an image to operate on.');
    Exit;
  end;
  n:=trunc(GetNumber('Replication factor:',8));
  SaveState;
  MakeBlocks(n);
  RestoreState;
end;



